home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / MOUSE_UT / MOUSTOOL / MAPEDIT.PAS < prev    next >
Pascal/Delphi Source File  |  1993-01-04  |  32KB  |  1,154 lines
  1. {Map Square Editor}
  2.  
  3. Uses
  4.   Crt,Dos,Graph,Palette,Drivers,Fonts,Mouse,Convert,MouseRs2,Box;
  5.  
  6. Var
  7.   Size,                    {size of map squares}
  8.   Color,                {current drawing color}
  9.   x,y,                    {cursor location}
  10.   LookX,LookY,
  11.   MaxRec,
  12.   i:  INTEGER;
  13.   LastMove,
  14.   cmd:  CHAR;
  15.   fp2:  FILE of AnyImage;
  16.   filenm:  STRING;
  17.   AltImage,
  18.   MyImage:  ^AnyImage;
  19.  
  20. { Table of mouse "buttons" on the screen.  Each entry contains the leftmost,
  21.   rightmost, topmost, and bottommost pixels (respectively) of the button. }
  22.  
  23. Const
  24.   mt: array[1..18,1..4] of INTEGER = (    {normal prompts}
  25.   (340,380,25,249),            {select color}
  26.   (51,211,21,181),            {draw pixel}
  27.   (400,620,68,81),            {save}
  28.   (400,620,82,95),            {read}
  29.   (400,620,96,109),            {re-read}
  30.   (400,620,110,123),            {palette functions}
  31.   (400,620,124,137),            {clear}
  32.   (400,620,138,151),            {view last images read}
  33.   (400,620,152,165),            {look}
  34.   (400,620,166,179),            {fill}
  35.   (400,620,180,193),            {flip left to right}
  36.   (400,620,194,207),            {flip top to bottom}
  37.   (400,620,208,221),            {rotate}
  38.   (400,620,222,235),            {shift right}
  39.   (400,620,236,249),            {shift left}
  40.   (400,620,250,265),            {shift up}
  41.   (400,620,266,279),            {shift down}
  42.   (400,620,280,293) );            {quit}
  43.  
  44.   mtp: array[1..5,1..4] of INTEGER = (    {palette prompts}
  45.   (400,620,84,97),            {Save palette}
  46.   (400,620,98,111),            {Load palette}
  47.   (400,620,112,125),            {Change a color}
  48.   (400,620,126,139),            {Rotate a color}
  49.   (400,620,140,153) );            {Default palette}
  50.  
  51.   PalQues: array[1..5] of STRING = (    {palette questions}
  52.   'Save','Load','Change','Rotate','Default');
  53.  
  54.   PutQues: array[1..5] of STRING = (    {PutImage questions}
  55.   'Normal','XOR','OR','AND','NOT');
  56.  
  57.   ChangeQues: array[1..7] of STRING = (    {Change color questions}
  58.   'r','g','b','R','G','B','Done');
  59.  
  60. procedure MouseOn;
  61. { turn on correct mouse cursor according to its current position }
  62. begin
  63.   case MouseLocate(Mx,My,18,@mt) of
  64.     0:  MouseCursorOn(Mx,My,HAND);
  65.     2:  MouseCursorOn(Mx,My,ARROW);
  66.     else  MouseCursorOn(Mx,My,FINGER);
  67.   end;
  68. end;
  69.  
  70. procedure MouseColor;
  71. { set drawing color from mouse }
  72. begin
  73.   Color := (My - 25) div 14;
  74.   GotoXY(52,2);
  75.   TextColor(Color);
  76.   if MyPal[Color,0] = 0 then
  77.     TextColor(LightGray);
  78.   if Color < 10 then
  79.     Write('Color=',Color,' ')
  80.   else
  81.     Write('Color=',Chr(Color+55));
  82. end;
  83.  
  84. procedure Prompts;
  85. { main menu prompts }
  86. begin
  87.   TextColor(Cyan);
  88.   GotoXY(52,3); Write('Select color by number.   ');
  89.   GotoXY(52,4); Write('Hit space to draw.        ');
  90.   GotoXY(52,5); Write('Use arrows to move.       ');
  91.   GotoXY(52,6); Write('S = Save file             ');
  92.   GotoXY(52,7); Write('R = Read file             ');
  93.   GotoXY(52,8); Write('W = Re-read               ');
  94.  
  95.   GotoXY(52,9); Write('P = Palette functions     ');
  96.   GotoXY(52,10);Write('X = Clear drawing         ');
  97.   GotoXY(52,11);Write('V = View last images read ');
  98.   GotoXY(52,12);Write('L = Look at adjacent parts');
  99.   GotoXY(52,13);Write('Z = Fill                  ');
  100.   GotoXY(52,14);Write('< = Flip left to right    ');
  101.   GotoXY(52,15);Write('> = Flip top to bottom    ');
  102.   GotoXY(52,16);Write('@ = Rotate clock-wise     ');
  103.   GotoXY(52,17);Write('- = Shift Right           ');
  104.   GotoXY(52,18);Write('+ = Shift Left            ');
  105.   GotoXY(52,19);Write('^ = Shift Up              ');
  106.   GotoXY(52,20);Write('| = Shift Down           ');
  107.   GotoXY(52,21);Write('Q = Quit                  ');
  108.   TextColor(Green);
  109. end;
  110.  
  111. procedure DefaultPalette;
  112. { load default palette }
  113. begin
  114.   for i := 0 to 15 do begin
  115.     SetPalette(i,NormPal[i]);
  116.     MyPal[i,0] := NormPal[i];
  117.     MyPal[i,1] := $FF;
  118.   end;
  119.   GotoXY(50,24);
  120.   TextColor(Black);ClrEol;
  121.   TextColor(Green);
  122.   Write('Palette: DEFAULT');
  123. end;
  124.  
  125. function RGBconvert(num:  STRING): INTEGER;
  126. { convert a string rgbRGB value to a number }
  127. var
  128.   i,j:  INTEGER;
  129. begin
  130.   j := 0;                {initialize new color}
  131.   for i := 1 to 6 do begin        {check each bit in color selection}
  132.     j := j * 2;
  133.     if num[i] = '1' then j := j + 1;
  134.   end;
  135.   RGBconvert := j;
  136. end;
  137.  
  138. procedure NewPalette;
  139. { load a new palette from disk }
  140. var
  141.   filenm:  STRING;
  142.   fp2:  TEXT;
  143.   j,i:  INTEGER;
  144. begin
  145.   filenm := '';
  146.   filenm := MGetFile('*.pal','Select palette file name:');
  147.   if filenm[0] = #255 then exit;    {abort if nothing entered}
  148.   if Pos('.',filenm) = 0 then
  149.     filenm := filenm + '.pal';
  150. {I$-}
  151.   Assign(fp2,filenm);
  152.   Reset(fp2);
  153. {I$+}
  154.   if IOResult <> 0 then begin        {error in file}
  155.     GotoXY(5,22);Write('I/O ERROR');
  156.     Delay(1000);
  157.     TextColor(Black);
  158.     GotoXY(5,22);ClrEol;
  159.     TextColor(Green);
  160.   end
  161.   else begin
  162.     GotoXY(50,24);
  163.     TextColor(Black);ClrEol;
  164.     TextColor(Green);
  165.     Write('Palette: ',filenm);
  166.     for i := 0 to 15 do begin        {read in and set new palette}
  167.       ReadLn(fp2,j);
  168.       MyPal[i,0] := j;
  169.       SetPalette(i,j);
  170.       ReadLn(fp2,j);
  171.       MyPal[i,1] := j;
  172.     end;
  173.     Close(fp2);
  174.   end;
  175. end; {NewPalette procedure}
  176.  
  177. procedure SavePalette;
  178. { save a palette to disk }
  179. var
  180.   filenm:  STRING;
  181.   fp2:  TEXT;
  182.   i:  INTEGER;
  183. begin
  184.   filenm := '';
  185.   filenm := MGetFile('*.pal','Select palette file name:');
  186.   if filenm[0] = #255 then exit;    {abort if nothing entered}
  187.   if Pos('.',filenm) = 0 then
  188.     filenm := filenm + '.pal';
  189.   Assign(fp2,filenm);
  190.   Rewrite(fp2);
  191.   for i := 0 to 15 do begin        {write current palette}
  192.     WriteLn(fp2,MyPal[i,0]);
  193.     WriteLn(fp2,MyPal[i,1]);
  194.   end;
  195.   Close(fp2);
  196.   GotoXY(50,24);
  197.   TextColor(Black);ClrEol;
  198.   TextColor(Green);
  199.   Write('Palette: ',filenm);
  200. end; {NewPalette procedure}
  201.  
  202. procedure ChangeColor(ChColor,pal: INTEGER);
  203. { toggle bits within a palette color }
  204. var
  205.   Window: POINTER;
  206.   Heading,
  207.   temp: STRING;
  208.   x1,x2,
  209.   y1,y2,
  210.   i,j: INTEGER;
  211.   c: CHAR;
  212.   mtq: array[1..7,1..4] of INTEGER;        {buttons for questions}
  213. begin
  214.   temp := '';
  215.   j := MyPal[ChColor,pal];
  216.   for i := 6 downto 1 do begin        {find current color}
  217.     if j mod 2 = 1 then
  218.       temp := '1' + temp
  219.     else
  220.       temp := '0' + temp;
  221.     j := j div 2;
  222.   end;
  223.   MouseCursorOff(Mx,My);
  224.   SetTextJustify(LeftText,BottomText);
  225.   y1 := 160 - 10 * 7;                {establish window size}
  226.   y2 := 190 + 10 * 7;                {  for 7 answer window}
  227.   Heading := 'Select bit to toggle:';
  228.   x1 := 104 - 4 * Length(Heading);
  229.   x2 := 136 + 4 * Length(Heading);
  230.   GetMem(Window,ImageSize(x1,y1,x2,y2));
  231.   GetImage(x1,y1,x2,y2,Window^);
  232.   OutlineBox(x1,y1,x2,y2,LightGray,Brown);
  233.   SetColor(Magenta);
  234.   OutTextXY(x1+16,y1+20,Heading);        {print the heading}
  235.   SetColor(Blue);
  236.   for i := 1 to 7 do begin            {print the answers}
  237.     Circle(x1+17,y1+16+(i*20),7);
  238.     if temp[i] = '1' then begin
  239.       SetFillStyle(SolidFill,DarkGray);
  240.       FloodFill(x1+17,y1+16+(i*20),Blue);
  241.     end;
  242.     OutTextXY(x1+32,y1+21+(i*20),ChangeQues[i]);
  243.     mtq[i,1] := x1 + 5;                {mouse array position}
  244.     mtq[i,2] := x1 + 20;            {  for this button}
  245.     mtq[i,3] := y1 + 9 + (i * 20);
  246.     mtq[i,4] := y1 + 23 + (i * 20);
  247.   end;
  248.   MouseCursorOn(Mx,My,HAND);
  249.   repeat                    {repeat until done...}
  250.     i := 0;
  251.     repeat                    {use mouse until key hit...}
  252.       MStatus(NewButton,NewX,NewY);        {get mouse status}
  253.       if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  254.         MouseCursor(NewX,NewY,Mx,My,FINGER);
  255.       Mx := NewX; My := NewY;            {remember new location}
  256.       if NewButton <> Button then begin        {if button changed...}
  257.         if NewButton > 0 then            {if button now down...}
  258.           i := MouseLocate(Mx,My,Size,@mtq);
  259.         Button := NewButton;            {remember new button setting}
  260.       end; {if button changed}
  261.     until KeyPressed or (i > 0);
  262.     if KeyPressed then begin
  263.       c := ReadKey;
  264.       case c of
  265.         'r': begin i := 1; j := 32; end;
  266.         'g': begin i := 2; j := 16; end;
  267.         'b': begin i := 3; j := 8; end;
  268.         'R': begin i := 4; j := 4; end;
  269.         'G': begin i := 5; j := 2; end;
  270.         'B': begin i := 6; j := 1; end;
  271.         else Delay(1);
  272.       end; {case}
  273.     end {if KeyPressed}
  274.     else begin
  275.       c := #0;
  276.       case i of
  277.         1: begin i := 1; j := 32; end;
  278.         2: begin i := 2; j := 16; end;
  279.         3: begin i := 3; j := 8; end;
  280.         4: begin i := 4; j := 4; end;
  281.         5: begin i := 5; j := 2; end;
  282.         6: begin i := 6; j := 1; end;
  283.         7: c := #13;
  284.         else Delay(1);
  285.       end; {case}
  286.     end;
  287.     if c <> #13 then begin
  288.       MouseCursorOff(Mx,My);
  289.       if temp[i] = '1' then begin    {toggle digit in string}
  290.         temp[i] := '0';
  291.         SetFillStyle(SolidFill,LightGray);
  292.         FloodFill(x1+17,y1+16+(i*20),Blue);
  293.       end
  294.       else begin
  295.         temp[i] := '1';
  296.     SetFillStyle(SolidFill,DarkGray);
  297.         FloodFill(x1+17,y1+16+(i*20),Blue);
  298.       end;
  299.       MouseCursorOn(Mx,My,FINGER);
  300.       MyPal[ChColor,pal] := MyPal[ChColor,pal] Xor j;
  301.       if pal = 0 then begin
  302.         MyPal[ChColor,1] := $FF;
  303.         SetPalette(ChColor,MyPal[ChColor,0]);{do the actual change}
  304.       end;
  305.     end;
  306.   until c = #13;
  307.   MouseCursorOff(Mx,My);
  308.   PutImage(x1,y1,Window^,NormalPut);
  309.   MouseCursorOn(Mx,My,HAND);
  310.   FreeMem(Window,ImageSize(x1,y1,x2,y2));
  311. end;
  312.  
  313. procedure ChangePalette;
  314. { change a color in the palette }
  315. var
  316.   c:  CHAR;
  317.   ChColor:  INTEGER;
  318. begin
  319.   c := MouseReadKey('Select color to change (0-9,A-F)');
  320.   if (c = #27) or (c = #13) then exit;
  321.   if c = #0 then
  322.     ChColor := (My - 25) div 14
  323.   else
  324.     ChColor := Ord(UpCase(c)) - 48;
  325.   if ChColor > 9 then ChColor := ChColor - 7;
  326.   ChangeColor(ChColor,0);
  327.   GotoXY(50,24);
  328.   TextColor(Black);ClrEol;
  329.   TextColor(Green);
  330.   Write('Palette: <none>');
  331. end; {ChangePalette procedure}
  332.  
  333. procedure RotatePalette;
  334. { set up a color to rotate (palette switch) }
  335. var
  336.   c:  CHAR;
  337.   RotColor:  INTEGER;
  338. begin
  339.   c := MouseReadKey('Select color to rotate (0-9,A-F)');
  340.   if (c = #27) or (c = #13) then exit;
  341.   if c = #0 then
  342.     RotColor := (My - 25) div 14
  343.   else
  344.     RotColor := Ord(UpCase(c)) - 48;
  345.   if RotColor > 9 then RotColor := RotColor - 7;
  346.   MyPal[RotColor,1] := MyPal[RotColor,0];
  347.   ChangeColor(RotColor,1);
  348.   GotoXY(50,24);
  349.   TextColor(Black);ClrEol;
  350.   TextColor(Green);
  351.   Write('Palette: <none>');
  352. end; {RotatePalette procedure}
  353.  
  354. procedure Look;
  355. { load adjacent parts of image to look at }
  356. var
  357.   temp:  STRING;
  358.   c:  CHAR;
  359.   code:  INTEGER;
  360.   rec:  WORD;
  361.   MyImage:  ^AnyImage;
  362. begin
  363.   SetFillStyle(SolidFill,Black);
  364.   Bar(234,80,266,112);
  365.   TextColor(Red);
  366.   GotoXY(31,7);Write('1 2');
  367.   GotoXY(31,8);Write('3 4');
  368.   for i := 1 to 4 do begin
  369.     filenm := MGetFile('*.pic','File '+ItoS(i)+' or Enter for drawing:');
  370.     if filenm[0] = #255 then begin    {abort if ESC hit}
  371.       exit;
  372.     end;    
  373.     if filenm = '' then begin            {if no name entered...}
  374.       case i of                    {this is where current goes}
  375.         1: begin LookX := 234;LookY := 80;end;
  376.         2: begin LookX := 250;LookY := 80;end;
  377.         3: begin LookX := 234;LookY := 96;end;
  378.         4: begin LookX := 250;LookY := 96;end;
  379.       end; {case}
  380.       GetMem(MyImage,Size);
  381.       GetImage(21,21,36,36,MyImage^);
  382.       PutImage(LookX,LookY,MyImage^,NormalPut);
  383.       FreeMem(MyImage,Size);
  384.     end
  385.     else begin                    {if name entered...}
  386.       if Pos('.',filenm) = 0 then
  387.         filenm := filenm + '.pic';
  388. {$I-}
  389.       Assign(fp2,filenm);            {open file}
  390.       Reset(fp2);
  391. {$I+}
  392.       if IOResult <> 0 then begin
  393.         GotoXY(5,22);Write('I/O ERROR');
  394.         Delay(1000);
  395.         TextColor(Black);
  396.         GotoXY(5,22);ClrEol;
  397.         TextColor(Red);
  398.       end
  399.       else begin
  400.         TextColor(Black);
  401.         GotoXY(5,22);ClrEol;
  402.         TextColor(Red);
  403.         if FileSize(fp2) > 1 then begin
  404.           repeat
  405.             GotoXY(5,22);Write('Record number (1-',FileSize(fp2),'): ');
  406.             TextColor(Black);ClrEol;
  407.             TextColor(Red);
  408.             ReadLn(temp);
  409.             Val(temp,rec,code);
  410.           until (rec > 0) and (rec <= FileSize(fp2)) and (code = 0);
  411.           Seek(fp2,rec-1);
  412.         end;
  413.         GetMem(MyImage,Size);                {reserve memory}
  414.         Read(fp2,MyImage^);
  415.         Close(fp2);
  416.         case i of
  417.           1: PutImage(234,80,MyImage^,Normalput);
  418.           2: PutImage(250,80,MyImage^,Normalput);
  419.           3: PutImage(234,96,MyImage^,Normalput);
  420.           4: PutImage(250,96,MyImage^,Normalput);
  421.         end; {case}
  422.         FreeMem(MyImage,Size);                {free memory}
  423.       end;
  424.     end;
  425.   end;
  426.   TextColor(Black);
  427.   GotoXY(5,22);ClrEol;
  428. end; {Look procedure}
  429.  
  430. procedure PalFunc;
  431. { select palette function }
  432. var
  433.   func:  CHAR;
  434. begin
  435.   case MouseQuestion(5,'Select a palette function',@PalQues) of
  436.     1:  SavePalette;
  437.     2:  NewPalette;
  438.     3:  ChangePalette;
  439.     4:  RotatePalette;
  440.     5:  DefaultPalette;
  441.     else Delay(1);
  442.   end; {case}
  443. end;
  444.  
  445. procedure DrawCursor(color: INTEGER);
  446. { draw the cursor }
  447. begin
  448.   SetColor(color);
  449.   Rectangle(51+x*10,21+y*10,61+x*10,31+y*10);
  450. end;
  451.  
  452. procedure PutIt(x,y,color:  INTEGER);
  453. { draw a pixel at several places so we can see the drawing several times }
  454. begin
  455.   PutPixel(x+21,y+21,Color);
  456.   PutPixel(x+234,y+21,Color);
  457.   PutPixel(x+250,y+21,Color);
  458.   PutPixel(x+266,y+21,Color);
  459.   PutPixel(x+234,y+37,Color);
  460.   PutPixel(x+250,y+37,Color);
  461.   PutPixel(x+266,y+37,Color);
  462.   PutPixel(x+234,y+53,Color);
  463.   PutPixel(x+250,y+53,Color);
  464.   PutPixel(x+266,y+53,Color);
  465.   if LookX <> 0 then
  466.     PutPixel(x+LookX,y+LookY,Color);
  467. end;
  468.  
  469. procedure SaveIt;
  470. { save image to file }
  471. var
  472.   FileRec: WORD;
  473. begin
  474.   TextColor(Brown);
  475.   GetMem(MyImage,Size);                {reserve memory}
  476.   GetImage(21,21,36,36,MyImage^);        {get image}
  477.   filenm := MGetFile('*.pic','Select picture file name:');
  478.   if filenm[0] = #255 then exit;        {abort if nothing entered}
  479.   if Pos('.',filenm) = 0 then
  480.     filenm := filenm + '.pic';
  481.   TextColor(Brown);
  482. {$I-}
  483.   Assign(fp2,filenm);
  484.   Reset(fp2);
  485. {$I+}
  486.   if IOResult <> 0 then begin            {if new file...}
  487.     GotoXY(5,22);Write('New File');
  488.     Rewrite(fp2);                {create it}
  489.     Write(fp2,MyImage^);            {write image to beginning}
  490.     Close(fp2);
  491.     FileRec := 1;
  492.   end
  493.   else begin                    {if existing file...}
  494.     GotoXY(5,22);Write('Record number (1-',FileSize(fp2)+1,'): ');
  495.     ReadLn(FileRec);
  496.     Seek(fp2,FileRec-1);            {seek desired record}
  497.     Write(fp2,MyImage^);            {write image there}
  498.     Close(fp2);
  499.   end;
  500.   TextColor(Black);
  501.   GotoXY(5,22);ClrEol;
  502.   GotoXY(50,23);
  503.   TextColor(Black);ClrEol;
  504.   TextColor(Green);
  505.   Write('  Image: ',filenm,' (',FileRec,')');
  506. end;
  507.  
  508. procedure Clear;
  509. { clear drawing areas }
  510. var
  511.   i,j:  INTEGER;
  512. begin
  513.   SetFillStyle(SolidFill,Black);
  514.   Bar(21,21,36,36);
  515.   Bar(51,21,210,180);
  516.   Bar(234,21,281,68);
  517.   SetColor(DarkGray);
  518.   for i := 0 to 16 do begin            {make grid in big box}
  519.     Line(51+(i*10),21,51+(i*10),181);
  520.     Line(51,21+(i*10),211,21+(i*10));
  521.   end;
  522.   DrawCursor(Yellow);                {initialize cursor}
  523.   GotoXY(50,23);
  524.   TextColor(Black);ClrEol;
  525.   TextColor(Green);
  526.   Write('  Image: <none>');
  527. end; {Clear procedure}
  528.  
  529. procedure Center;
  530. { move cursor to 7,7 }
  531. begin
  532.   DrawCursor(DarkGray);
  533.   x := 7; y := 7;
  534.   DrawCursor(Yellow);
  535. end;
  536.  
  537. procedure Home;
  538. { move cursor to 0,0 }
  539. begin
  540.   DrawCursor(DarkGray);
  541.   x := 0; y := 0;
  542.   DrawCursor(Yellow);
  543. end;
  544.  
  545. procedure GoEnd;
  546. { move cursor to 0,15 }
  547. begin
  548.   DrawCursor(DarkGray);
  549.   x := 0; y := 15;
  550.   DrawCursor(Yellow);
  551. end;
  552.  
  553. procedure TopRight;
  554. { move cursor to 15,0 }
  555. begin
  556.   DrawCursor(DarkGray);
  557.   x := 15; y := 0;
  558.   DrawCursor(Yellow);
  559. end;
  560.  
  561. procedure BottomRight;
  562. { move cursor to 15,15 }
  563. begin
  564.   DrawCursor(DarkGray);
  565.   x := 15; y := 15;
  566.   DrawCursor(Yellow);
  567. end;
  568.  
  569. procedure FarLeft;
  570. { move cursor to 0,y }
  571. begin
  572.   DrawCursor(DarkGray);
  573.   x := 0;
  574.   DrawCursor(Yellow);
  575. end;
  576.  
  577. procedure FarRight;
  578. { move cursor to 15,y }
  579. begin
  580.   DrawCursor(DarkGray);
  581.   x := 15;
  582.   DrawCursor(Yellow);
  583. end;
  584.  
  585. procedure UpLeft;
  586. { move the cursor up and left }
  587. begin
  588.   DrawCursor(DarkGray);
  589.   if y > 0 then
  590.     y := y - 1;
  591.   if x > 0 then
  592.     x := x - 1;
  593.   DrawCursor(Yellow);
  594. end;
  595.  
  596. procedure DownLeft;
  597. { move the cursor down and left }
  598. begin
  599.   DrawCursor(DarkGray);
  600.   if y < 15 then
  601.     y := y + 1;
  602.   if x > 0 then
  603.     x := x - 1;
  604.   DrawCursor(Yellow);
  605. end;
  606.  
  607. procedure UpRight;
  608. { move the cursor up and right }
  609. begin
  610.   DrawCursor(DarkGray);
  611.   if y > 0 then
  612.     y := y - 1;
  613.   if x < 15 then
  614.     x := x + 1;
  615.   DrawCursor(Yellow);
  616. end;
  617.  
  618. procedure DownRight;
  619. { move the cursor down and right }
  620. begin
  621.   DrawCursor(DarkGray);
  622.   if y < 15 then
  623.     y := y + 1;
  624.   if x < 15 then
  625.     x := x + 1;
  626.   DrawCursor(Yellow);
  627. end;
  628.  
  629. procedure UpArrow;
  630. { move the cursor up }
  631. begin
  632.   if y > 0 then begin
  633.     DrawCursor(DarkGray);
  634.     y := y - 1;
  635.     DrawCursor(Yellow);
  636.   end;
  637. end;
  638.  
  639. procedure DownArrow;
  640. { move the cursor up }
  641. begin
  642.   if y < 15 then begin
  643.     DrawCursor(DarkGray);
  644.     y := y + 1;
  645.     DrawCursor(Yellow);
  646.   end;
  647. end;
  648.  
  649. procedure LeftArrow;
  650. { move the cursor up }
  651. begin
  652.   if x > 0 then begin
  653.     DrawCursor(DarkGray);
  654.     x := x - 1;
  655.     DrawCursor(Yellow);
  656.   end;
  657. end;
  658.  
  659. procedure RightArrow;
  660. { move the cursor up }
  661. begin
  662.   if x < 15 then begin
  663.     DrawCursor(DarkGray);
  664.     x := x + 1;
  665.     DrawCursor(Yellow);
  666.   end;
  667. end;
  668.  
  669. procedure JustDrawIt;
  670. { like DrawIt without the cursor movements }
  671. begin
  672.   PutIt(x,y,Color);
  673.   SetFillStyle(SolidFill,Color);
  674.   Bar(52+x*10,22+y*10,60+x*10,30+y*10);
  675. end;
  676.  
  677. procedure MouseDrawIt;
  678. { draw a pixel from mouse }
  679. var
  680.   DrawX,DrawY:  INTEGER;
  681. begin
  682.   DrawX := x;                {save cursor location}
  683.   DrawY := y;
  684.   x := (Mx-52) div 10;            {set cursor to mouse position}
  685.   y := (My-22) div 10;
  686.   MouseCursorOff(Mx,My);
  687.   JustDrawIt;                {draw pixel}
  688.   MouseCursorOn(Mx,My,ARROW);
  689.   x := DrawX;                {recall cursor location}
  690.   y := DrawY;
  691. end; {MouseDrawIt procedure}
  692.  
  693. procedure DrawIt;
  694. { draw a pixel at current location }
  695. begin
  696.   PutIt(x,y,Color);
  697.   SetFillStyle(SolidFill,Color);
  698.   Bar(52+x*10,22+y*10,60+x*10,30+y*10);
  699.   case LastMove of
  700.     #71:  UpLeft;
  701.     #119: Home;
  702.     #79:  DownLeft;
  703.     #117: GoEnd;
  704.     #73:  UpRight;
  705.     #132: TopRight;
  706.     #81:  DownRight;
  707.     #118: BottomRight;
  708.     #76:  Center;
  709.     #72:  UpArrow;
  710.     #80:  DownArrow;
  711.     #75:  LeftArrow;
  712.     #115: FarLeft;
  713.     #77:  RightArrow;
  714.     #116: FarRight;
  715.     else Delay(1);
  716.    end; {case}
  717. end;
  718.  
  719. procedure Flip(FlipType:  INTEGER);
  720. { flip drawing }
  721. var
  722.   Savec,
  723.   Savex,
  724.   Savey:  INTEGER;
  725.   MyImage:  ^AnyImage;
  726. begin
  727.   GetMem(MyImage,Size);
  728.   GetImage(21,21,36,36,MyImage^);        {copy image outside normal}
  729.   PutImage(21,51,MyImage^,NormalPut);        {  location}
  730.   FreeMem(MyImage,Size);
  731.   Savex := x;                    {save cursor position}
  732.   Savey := y;
  733.   Savec := color;
  734.   for x := 0 to 15 do begin            {redraw it}
  735.     for y := 0 to 15 do begin
  736.       case FlipType of
  737.         1: color := GetPixel(36-x,51+y);    {left to right}
  738.         2: color := GetPixel(21+x,66-y);    {top to bottom}
  739.         3: color := GetPixel(21+y,66-x);    {rotate}
  740.       end; {case}
  741.       JustDrawIt;
  742.     end;
  743.   end;
  744.   x := Savex;
  745.   y := Savey;
  746.   color := Savec;
  747. end;
  748.  
  749. procedure Shift(ShiftType:  INTEGER);
  750. { shift drawing one pixel }
  751. var
  752.   Savec,
  753.   Savex,
  754.   Savey:  INTEGER;
  755.   MyImage:  ^AnyImage;
  756. begin
  757.   GetMem(MyImage,Size);
  758.   GetImage(21,21,36,36,MyImage^);        {copy image outside normal}
  759.   PutImage(21,51,MyImage^,NormalPut);        {  location}
  760.   FreeMem(MyImage,Size);
  761.   Savex := x;                    {save cursor position}
  762.   Savey := y;
  763.   Savec := color;
  764.   for x := 0 to 15 do begin            {redraw it}
  765.     for y := 0 to 15 do begin
  766.       case ShiftType of
  767.         1: color := GetPixel(20+x,51+y);    {shift right}
  768.         2: color := GetPixel(22+x,51+y);    {shift left}
  769.         3: color := GetPixel(21+x,52+y);    {shift up}
  770.         4: color := GetPixel(21+x,50+y);    {shift down}
  771.       end; {case}
  772.       JustDrawIt;
  773.     end;
  774.   end;
  775.   x := Savex;
  776.   y := Savey;
  777.   color := Savec;
  778. end;
  779.  
  780. procedure Fill;
  781. { fill in an area }
  782. var
  783.   flag:  BOOLEAN;
  784.   OldColor,
  785.   savex,savey,
  786.   xbegin,xend,
  787.   fillx,filly:  INTEGER;
  788. begin
  789.   savex := x; savey := y;        {remember where cursor was}
  790.   fillx := x; filly := y;
  791.   OldColor := GetPixel(21+fillx,21+filly);
  792.   repeat
  793.     repeat                {find left edge of region}
  794.       fillx := fillx - 1;
  795.     until (fillx < 0) or (GetPixel(21+fillx,21+filly) <> OldColor);
  796.     fillx := fillx + 1;
  797.     xbegin := fillx;
  798.     repeat                {fill from left to right edge}
  799.       x := fillx; y := filly;
  800.       JustDrawIt;
  801.       fillx := fillx + 1;
  802.     until (GetPixel(21+fillx,21+filly) <> OldColor) or (fillx > 15);
  803.     filly := filly - 1;            {back up a line}
  804.     flag := FALSE;
  805.     for i := xbegin to fillx-1 do begin    {see if empty area on previous line}
  806.       if GetPixel(21+i,21+filly) = OldColor then begin
  807.         fillx := i;            {yes, remember where}
  808.         flag := TRUE;
  809.       end;
  810.     end; {for i}
  811.   until (flag = FALSE) or (filly < 0);
  812.   x := savex; y := savey;        {restore cursor}
  813. end; {Fill procedure}
  814.  
  815. procedure ViewAll;
  816. { view page 1 to see last group of images read in }
  817. begin
  818.   MouseCursorOff(Mx,My);
  819.   SetActivePage(1);                {select alternate page}
  820.   SetVisualPage(1);
  821.   MouseCursorOn(Mx,My,FINGER);
  822.   repeat
  823.   until MouseYN(300,300,'Continue?');
  824.   MouseCursorOff(Mx,My);
  825.   SetActivePage(0);                {select normal page}
  826.   SetVisualPage(0);
  827.   MouseCursorOn(Mx,My,HAND);
  828. end;
  829.  
  830. procedure ReadIt;
  831. { read image from file }
  832. var
  833.   temp:  STRING;
  834.   SaveColor:  INTEGER;
  835.   FileRec,
  836.   PutType:  WORD;
  837. begin
  838.   SaveColor := Color;
  839.   TextColor(Brown);
  840.   GetMem(MyImage,Size);                {reserve memory}
  841.   filenm := MGetFile('*.pic','Select picture file name:');
  842.   if filenm[0] = #255 then exit;        {abort if nothing entered}
  843.   if Pos('.',filenm) = 0 then
  844.     filenm := filenm + '.pic';
  845. {$I-}
  846.   Assign(fp2,filenm);                {try to open file}
  847.   Reset(fp2);
  848. {$I+}
  849.   if IOResult <> 0 then begin            {if no such file...}
  850.     GotoXY(5,22);Write('I/O ERROR');
  851.     Delay(1000);
  852.     TextColor(Black);
  853.     GotoXY(5,22);ClrEol;
  854.     TextColor(Green);
  855.   end
  856.   else begin                    {if file exists...}
  857.     if FileSize(fp2) > 1 then begin
  858.       SetColor(Yellow);
  859.       MaxRec := FileSize(fp2);            {get # records in file}
  860.       MouseCursorOff(Mx,My);
  861.       SetActivePage(1);                {select alternate page}
  862.       SetFillStyle(SolidFill,Black);
  863.       Bar(0,0,639,349);                {clear it}
  864.       GetMem(AltImage,Size);            {get memory for images}
  865.       Reset(fp2);                {open file to beginning}
  866.       for i := 0 to MaxRec-1 do begin        {now draw each image in file}
  867.         Read(fp2,AltImage^);
  868.         PutImage(32+(i mod 18)*32,28+(i div 18)*40,AltImage^,NormalPut);
  869.         OutTextXY(32+(i mod 18)*32,54+(i div 18)*40,ItoS(i+1));
  870.       end;
  871.       OutlineBox(570,320,629,339,Red,Yellow);
  872.       OutTextXY(581,334,'ABORT');
  873.       SetVisualPage(1);
  874.       MoveTo(40,310);
  875.       SetColor(Yellow);
  876.       OutText('Record number (1-'+ItoS(MaxRec)+'): ');
  877.       MouseCursorOn(Mx,My,FINGER);
  878.       FileRec := 0;
  879.       repeat                    {use mouse until key hit...}
  880.         MStatus(NewButton,NewX,NewY);        {get mouse status}
  881.           if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  882.             MouseCursor(NewX,NewY,Mx,My,FINGER);
  883.         Mx := NewX; My := NewY;            {remember new location}
  884.         if NewButton <> Button then begin    {if button changed...}
  885.           if NewButton > 0 then            {if button now down...}
  886.             i := ((Mx-32) div 32) + 18 * ((My-28) div 40) + 1;
  887.               if i <= MaxRec then FileRec := i;
  888.         if (Mx>570) and (My>320) then begin    {if abort...}
  889.           MouseCursorOff(Mx,My);
  890.           SetActivePage(0);
  891.           SetVisualPage(0);
  892.           MouseCursorOn(Mx,My,FINGER);
  893.           exit;                {just exit}
  894.         end;
  895.       Button := NewButton;            {remember new button setting}
  896.         end; {if button changed}
  897.       until KeyPressed or (FileRec > 0);
  898.       MouseCursorOff(Mx,My);
  899.       if KeyPressed then begin
  900.         Input(temp);
  901.         Val(temp,FileRec,i);
  902.       end; {if KeyPressed}
  903.       SetActivePage(0);
  904.       SetVisualPage(0);
  905.       MouseCursorOn(Mx,My,FINGER);
  906.     end
  907.     else FileRec := 1;
  908.     PutType := MouseQuestion(5,'PutImage type:',@PutQues) - 1;
  909.     TextColor(Brown);
  910.     Seek(fp2,FileRec-1);
  911.     Read(fp2,MyImage^);
  912.     Close(fp2);
  913.     PutImage(21,21,MyImage^,PutType);        {put image in small box}
  914.     MouseCursorOff(Mx,My);
  915.     DrawCursor(DarkGray);            {erase cursor}
  916.     for x := 0 to 15 do begin            {now put it in big box}
  917.       for y := 0 to 15 do begin
  918.         Color := GetPixel(21+x,21+y);
  919.         JustDrawIt;
  920.       end;
  921.     end;
  922.     MouseOn;
  923.     x := 0; y := 0;
  924.     Color := SaveColor;                {restore drawing color}
  925.     DrawCursor(Yellow);
  926.     GotoXY(50,23);
  927.     TextColor(Black);ClrEol;
  928.     TextColor(Green);
  929.     Write('  Image: ',filenm,'(',FileRec,')');
  930.   end;
  931. end;
  932.  
  933. procedure ReRead;
  934. { reread an image from the last file opened }
  935. var
  936.   tempstr:  STRING;
  937.   temp:  POINTER;
  938.   SaveColor,
  939.   FileRec:  INTEGER;
  940. begin
  941.   SaveColor := color;
  942.   MouseCursorOff(Mx,My);
  943.   SetActivePage(1);                {select alternate page}
  944.   SetVisualPage(1);
  945.  
  946.   SetColor(Yellow);
  947.   MoveTo(40,310);            {prompt for desired image}
  948.   OutText('Record number (1-'+ItoS(MaxRec)+'): ');
  949.   SetFillStyle(SolidFill,Black);
  950.   Bar(GetX,GetY,GetX+32,GetY-8);
  951.   MouseCursorOn(Mx,My,FINGER);
  952.   FileRec := 0;
  953.   MStatus(NewButton,NewX,NewY);            {get mouse status}
  954.   Button := NewButton;
  955.   repeat                    {use mouse until key hit...}
  956.     MStatus(NewButton,NewX,NewY);        {get mouse status}
  957.       if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  958.         MouseCursor(NewX,NewY,Mx,My,FINGER);
  959.     Mx := NewX; My := NewY;            {remember new location}
  960.     if NewButton <> Button then begin        {if button changed...}
  961.       if NewButton > 0 then begin        {if button now down...}
  962.         i := ((Mx-32) div 32) + 18 * ((My-28) div 40) + 1;
  963.         if i <= MaxRec then FileRec := i;
  964.         if (Mx>570) and (My>320) then begin    {if abort...}
  965.           MouseCursorOff(Mx,My);
  966.           SetActivePage(0);
  967.           SetVisualPage(0);
  968.           MouseCursorOn(Mx,My,FINGER);
  969.           exit;                    {just exit}
  970.         end; {if abort}
  971.       end; {if button changed}
  972.       Button := NewButton;            {remember new button setting}
  973.     end; {if button changed}
  974.   until KeyPressed or (FileRec > 0);
  975.   MouseCursorOff(Mx,My);
  976.   if KeyPressed then begin            {key was pressed, get image}
  977.     Input(tempstr);                {number from keyboard}
  978.     Val(tempstr,FileRec,i);
  979.   end; {if KeyPressed}
  980.  
  981.   FileRec := FileRec - 1;
  982.   GetMem(temp,ImageSize(0,0,15,15));        {get the desired image}
  983.   GetImage(32+(FileRec mod 18)*32,28+(FileRec div 18)*40,
  984.            47+(FileRec mod 18)*32,43+(FileRec div 18)*40,temp^);
  985.   SetActivePage(0);
  986.   SetVisualPage(0);
  987.  
  988.   PutImage(21,21,temp^,NormalPut);        {put image in small box}
  989.   DrawCursor(DarkGray);                {erase cursor}
  990.   for x := 0 to 15 do begin            {now put it in big box}
  991.     for y := 0 to 15 do begin
  992.       Color := GetPixel(21+x,21+y);
  993.       JustDrawIt;
  994.     end;
  995.   end;
  996.   x := 0; y := 0;
  997.   Color := SaveColor;                {restore drawing color}
  998.   DrawCursor(Yellow);
  999.   GotoXY(50,23);
  1000.   TextColor(Black);ClrEol;
  1001.   TextColor(Green);
  1002.   Write('  Image: ',filenm,'(',FileRec+1,')');
  1003.   FreeMem(temp,ImageSize(0,0,15,15));
  1004.  
  1005.   MouseCursorOn(Mx,My,FINGER);
  1006. end; {ReRead procedure}
  1007.  
  1008. begin {Main routine}
  1009.   if RegisterBGIdriver(@EGAVGADriverProc) < 0 then
  1010.     Abort('EGA/VGA');
  1011.   Initialize;                    {initialize graphics}
  1012.   PalFlag := 1;
  1013.   GetIntVec($1C,Int1CSave);            {save interrupt vector}
  1014.   SetIntVec($1C,New1CInt);            {install timer interrupt}
  1015.  
  1016.   LookX := 0; LookY := 0;            {no look image now}
  1017.   DefaultPalette;                {set up normal palette}
  1018.   Size := ImageSize(0,0,15,15);            {size of images}
  1019.   x := 0; y := 0;                {initialize cursor}
  1020.   SetColor(LightGray);
  1021.   Rectangle(19,19,38,38);            {outline drawing areas}
  1022.   Rectangle(50,20,212,182);
  1023.   Rectangle(310,20,390,255);            {outline color chart}
  1024.   Rectangle(339,24,381,250);
  1025.   for i := 0 to 15 do begin
  1026.     SetFillStyle(SolidFill,i);
  1027.     Bar(340,25+(i*14),380,39+(i*14));
  1028.     GotoXY(41,3+i);
  1029.     if i < 10 then
  1030.       Write(i:1)
  1031.     else
  1032.       Write(Chr(i+55));
  1033.   end;
  1034.   Clear;
  1035.   Prompts;
  1036.   Color := 0;
  1037.   if MReset = -1 then begin            {see if mouse installed}
  1038.     MLimit(0,639-MW,0,349-MH);            {set mouse limits}
  1039.     MPut(0,0);                    {reset mouse coordinates}
  1040.   end;
  1041.   Mx := 0; My := 0;                {reset mouse cursor}
  1042.   Button := 0;
  1043.   GetMem(MCurs,ImageSize(0,0,MW,MH));
  1044.   MouseCursorOn(0,0,HAND);
  1045.   repeat                    {repeat until quit}
  1046.     GotoXY(52,2);
  1047.     TextColor(Color);
  1048.     if MyPal[Color,0] = 0 then
  1049.       TextColor(LightGray);
  1050.     if Color < 10 then
  1051.       Write('Color=',Color,' ')
  1052.     else
  1053.       Write('Color=',Chr(Color+55));
  1054.     repeat                    {use mouse until key hit...}
  1055.       MStatus(NewButton,NewX,NewY);        {get mouse status}
  1056.       if (NewX <> Mx) or (NewY <> My) then    {mouse cursor moved!}
  1057.         case MouseLocate(NewX,NewY,18,@mt) of
  1058.           0:  MouseCursor(NewX,NewY,Mx,My,HAND);
  1059.           2:  MouseCursor(NewX,NewY,Mx,My,ARROW);
  1060.           else  MouseCursor(NewX,NewY,Mx,My,FINGER);
  1061.         end;
  1062.       Mx := NewX; My := NewY;            {remember new location}
  1063.       if NewButton <> Button then begin        {if button changed...}
  1064.         if NewButton > 0 then begin        {if button now down...}
  1065.           case MouseLocate(Mx,My,18,@mt) of    {do a command}
  1066.             1: MouseColor;            {set a color}
  1067.             2: MouseDrawIt;            {draw a pixel}
  1068.             3: SaveIt;
  1069.             4: ReadIt;
  1070.         5: ReRead;
  1071.         6: PalFunc;
  1072.         7: if MouseYN(200,200,'Confirm clear?') then Clear;
  1073.         8: ViewAll;
  1074.         9: Look;
  1075.         10: Fill;
  1076.         11: begin MouseCursor(Mx,My,Mx,My,1);Flip(1);MouseCursor(Mx,My,Mx,My,2);end;
  1077.         12: begin MouseCursor(Mx,My,Mx,My,1);Flip(2);MouseCursor(Mx,My,Mx,My,2);end;
  1078.         13: begin MouseCursor(Mx,My,Mx,My,1);Flip(3);MouseCursor(Mx,My,Mx,My,2);end;
  1079.         14: Shift(1);
  1080.         15: Shift(2);
  1081.         16: Shift(3);
  1082.         17: Shift(4);
  1083.         18: if MouseYN(200,200,'Confirm quit?') then Halt;
  1084.           else Delay(1);
  1085.           end; {case}
  1086.         end; {if button now down}
  1087.         Button := NewButton;            {remember new button setting}
  1088.       end; {if button changed}
  1089.     until KeyPressed;
  1090.     cmd := ReadKey;                {read a key}
  1091.     if cmd = #0 then begin
  1092.       cmd := ReadKey;                {2nd half of arrow key}
  1093.       LastMove := cmd;                {remember last move direction}
  1094.       case cmd of
  1095.         #71:  UpLeft;
  1096.         #119: Home;
  1097.         #79:  DownLeft;
  1098.         #117: GoEnd;
  1099.         #73:  UpRight;
  1100.         #132: TopRight;
  1101.         #81:  DownRight;
  1102.         #118: BottomRight;
  1103.         #76:  Center;
  1104.         #72:  UpArrow;
  1105.         #80:  DownArrow;
  1106.         #75:  LeftArrow;
  1107.         #115: FarLeft;
  1108.         #77:  RightArrow;
  1109.         #116: FarRight;
  1110.         else Begin Sound(440);Delay(250);NoSound;End;
  1111.        end; {case}
  1112.       cmd := #0;
  1113.     end
  1114.     else begin
  1115.       case UpCase(cmd) of
  1116.       '0': Color := 0;
  1117.       '1': Color := 1;
  1118.       '2': Color := 2;
  1119.       '3': Color := 3;
  1120.       '4': Color := 4;
  1121.       '5': Color := 5;
  1122.       '6': Color := 6;
  1123.       '7': Color := 7;
  1124.       '8': Color := 8;
  1125.       '9': Color := 9;
  1126.       'A': Color := 10;
  1127.       'B': Color := 11;
  1128.       'C': Color := 12;
  1129.       'D': Color := 13;
  1130.       'E': Color := 14;
  1131.       'F': Color := 15;
  1132.       'P': PalFunc;
  1133.       'L': Look;
  1134.       'S': SaveIt;
  1135.       'R': ReadIt;
  1136.       'V': ViewAll;
  1137.       'W': ReRead;
  1138.       'Q': if MouseYN(200,200,'Confirm quit <Y/N>?') then Halt;
  1139.       'X': if MouseYN(200,200,'Confirm clear?') then Clear;
  1140.       'Z': Fill;
  1141.       '-': Shift(1);                {shift right}
  1142.       '+': Shift(2);                {shift left}
  1143.       '^': Shift(3);                {shift up}
  1144.       '|': Shift(4);                {shift down}
  1145.       '<': Flip(1);
  1146.       '>': Flip(2);
  1147.       '@': Flip(3);
  1148.       ' ': DrawIt;
  1149.       else Begin Sound(440);Delay(250);NoSound;End;
  1150.       end; {case}
  1151.     end;
  1152.   until UpCase(Cmd) = 'Q';
  1153. end.
  1154.